home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istvs / ISTVS.MAC.f
Encoding:
Text File  |  1989-03-04  |  12.8 KB  |  439 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 3.1
  3. C---------------------------------------------------------
  4. C---------------------------------------------------------
  5. C    TOOLPACK/1    Release: 2.4
  6. C---------------------------------------------------------
  7. C---------------------------------------------------------
  8. C    TOOLPACK/1    Release: 2.4
  9. C---------------------------------------------------------
  10. C---------------------------------------------------------
  11. C    TOOLPACK/1    Release: 2.4
  12. C---------------------------------------------------------
  13.  
  14.  
  15.  
  16.  
  17.  
  18.  
  19.  
  20.  
  21. C                                   parameter length
  22.  
  23.  
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31. C following are for ZYCSDT (Canonicalise Symbol Data Types)
  32. C *****************************
  33. C *  Note:  The following macro definition should be set to the
  34. C *         maximum number of symbols expected in any single
  35. C *         program-unit.  On a virtual-memory system, it can
  36. C *         be set to the maximum number of symbols possible,
  37. C *         i.e.    "define(max_pu_syms,max_symbols)"
  38. C *
  39. C *         For non-virtual systems, this may take up too much space,
  40. C *         so make it smaller, e.g.
  41. C *                 "define(max_pu_syms,500)"
  42. C *****************************
  43. C * The following setting is in use at NAG Central Office:
  44.         PROGRAM ISTVS
  45.  
  46.         COMMON/VSIO/IODSYM,IODLST
  47.         INTEGER IODSYM,IODLST
  48.  
  49.         COMMON/VSSYMI/SYMIDX,NSYMS
  50.         INTEGER SYMIDX(1000),NSYMS
  51.  
  52.         INTEGER HEADER(81),SYMPTH(81),LSTPTH(81),I,
  53.      +          YY,MMM,DD,HH,MM,SS,MILLI
  54.  
  55.         INTEGER GETARG,OPEN,CREATE
  56.         EXTERNAL GETARG,OPEN,CREATE,ZYINSY,ZINIT,ZQUIT,ZMESS,PUTLIN,
  57.      +           PUTCH,ZTIME,ZTIMST,ZCHOUT
  58.  
  59.         CALL ZINIT
  60.  
  61.         IF (GETARG(1,SYMPTH,81).EQ.-100) CALL NAMES(1,SYMPTH)
  62.         IF (GETARG(2,LSTPTH,81).EQ.-100) CALL NAMES(2,LSTPTH)
  63.         IF (GETARG(3,HEADER,81).EQ.-100) CALL NAMES(3,HEADER)
  64.  
  65.         IODSYM=OPEN(SYMPTH,0)
  66.         IF (IODSYM.EQ.-1) CALL ERROR('Can''t open symbol path')
  67.         IODLST=CREATE(LSTPTH,1)
  68.         IF (IODLST.EQ.-1) CALL ERROR('Can''t create list path')
  69.  
  70.         CALL ZYINSY(IODSYM)
  71.  
  72.         CALL PUTLIN(HEADER,IODLST)
  73.         CALL ZCHOUT(': Symbol Table Listing, ',IODLST)
  74.         CALL ZTIME(YY,MMM,DD,HH,MM,SS,MILLI)
  75.         CALL ZTIMST(YY,MMM,DD,HH,MM,SS,HEADER)
  76.         CALL PUTLIN(HEADER,IODLST)
  77.         CALL PUTCH(10,IODLST)
  78.         CALL PUTCH(10,IODLST)
  79.         I=1
  80.  
  81.  100    CALL ZYGSSI(SYMIDX,NSYMS,I)
  82.         IF (NSYMS.EQ.0) THEN
  83.             CALL ZMESS('[ISTVS Normal Termination]',1)
  84.             CALL ZQUIT(-2)
  85.         END IF
  86.         CALL GETDAT
  87.         CALL SRTIDX
  88.         CALL PRINTS
  89.         I=I+1
  90.         GO TO 100
  91.  
  92.         END
  93. C ----------------------------------------------------------------------
  94. C
  95. C       N A M E S   -   Input names of files and so on
  96. C
  97.  
  98.         SUBROUTINE NAMES(NUMBER,STRING)
  99.         INTEGER NUMBER,STRING(81)
  100.  
  101.         INTEGER PROMPT(22,3),JUNK
  102.  
  103.         SAVE PROMPT
  104.  
  105.         INTEGER ZGTCMD
  106.         EXTERNAL ZPRMPT,ZGTCMD
  107.  
  108. C "Input symbol table: "
  109. C "Output listing file: "
  110. C "Header text: "
  111.  
  112.         DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,115,
  113.      +121,109,98,111,108,32,116,97,98,108,101,58,
  114.      +32,129/,
  115.      +       (PROMPT(I,2),I=1,22)/79,117,116,112,117,116,32,
  116.      +108,105,115,116,105,110,103,32,102,105,108,101,
  117.      +58,32,129/,
  118.      +       (PROMPT(I,3),I=1,14)/72,101,97,100,101,114,32,
  119.      +116,101,120,116,58,32,129/
  120.  
  121.         CALL ZPRMPT(PROMPT(1,NUMBER))
  122.         JUNK=ZGTCMD(STRING,0)
  123.  
  124.         END
  125. C ----------------------------------------------------------------------
  126. C
  127. C       G E T D A T   -   Get symbol data
  128. C
  129.  
  130.         SUBROUTINE GETDAT
  131.  
  132.         COMMON/VSSYMI/SYMIDX,NSYMS
  133.         INTEGER SYMIDX(1000),NSYMS
  134.  
  135.         COMMON/VSSYMD/SYMBOL
  136.         INTEGER SYMBOL(8,1000)
  137.  
  138.         INTEGER I
  139.  
  140.         DO 100 I=1,NSYMS
  141.  100        CALL ZYGTSY(SYMIDX(I),SYMBOL(1,I))
  142.  
  143.         END
  144. C ----------------------------------------------------------------------
  145. C
  146. C       S R T I D X   -   Sort symbol index
  147. C
  148. C       Sort key: Symbol type (then) Current position
  149. C                 (Current position is as sorted by name)
  150. C
  151.  
  152.         SUBROUTINE SRTIDX
  153.  
  154.         COMMON/VSSYMI/SYMIDX,NSYMS
  155.         INTEGER SYMIDX(1000),NSYMS
  156.  
  157.         COMMON/VSSYMD/SYMBOL
  158.         INTEGER SYMBOL(8,1000)
  159.  
  160.         INTEGER I,J,K,TMP(8),T
  161.  
  162. C We will use a form of straight insertion
  163.         DO 300 I=2,NSYMS
  164.             J=I-1
  165. C while J>1 and a(i).lt.a(j) do j=j-1
  166.  100        IF (SYMBOL(1,I) .LT. SYMBOL(1,J)) THEN
  167.                 J=J-1
  168.                 IF (J.GE.1) GOTO 100
  169.             END IF
  170.             J=J+1
  171.             DO 150 T=1,8
  172.  150            TMP(T)=SYMBOL(T,I)
  173.             DO 250 K=I,J+1,-1
  174.                 DO 200 T=1,8
  175.  200                SYMBOL(T,K)=SYMBOL(T,K-1)
  176.  250        CONTINUE
  177.             DO 275 T=1,8
  178.  275            SYMBOL(T,J)=TMP(T)
  179.  300    CONTINUE
  180.         END
  181. C ----------------------------------------------------------------------
  182. C
  183. C       P R I N T S   -   Print Symbols
  184. C
  185.  
  186.         SUBROUTINE PRINTS
  187.  
  188.         COMMON/VSIO/IODSYM,IODLST
  189.         INTEGER IODSYM,IODLST
  190.  
  191.         COMMON/VSSYMI/SYMIDX,NSYMS
  192.         INTEGER SYMIDX(1000),NSYMS
  193.  
  194.         COMMON/VSSYMD/SYMBOL
  195.         INTEGER SYMBOL(8,1000)
  196.  
  197.         INTEGER I,TEXT(134)
  198.  
  199.         EXTERNAL ZCHOUT,PUTCH,ZOBLNK,ZPTINT
  200.  
  201.         I=0
  202.  100    I=I+1
  203.         IF (SYMBOL(1,I).NE.4) GOTO 100
  204.  
  205.         CALL PUTCH(10,IODLST)
  206.         CALL ZCHOUT('Program Unit: ',IODLST)
  207.         CALL WRNAME(I)
  208.         IF (SYMBOL(4,I).GT.0) CALL ZCHOUT(' FUNCTION',iodlst)
  209.         CALL PUTCH(10,IODLST)
  210.         CALL WRBITS(I)
  211.  
  212.         I=1
  213.         IF (SYMBOL(1,I).EQ.1 .AND. I.LE.NSYMS) THEN
  214.             CALL ZMESS('        Labels:',IODLST)
  215.  200        CALL ZOBLNK(12,IODLST)
  216.             CALL WRNAME(I)
  217.             CALL ZCHOUT(', Node ',IODLST)
  218.             CALL ZPTINT(SYMBOL(4,I),1,IODLST)
  219.             CALL ZCHOUT(', Refs (ctl,do,io,ass) ',IODLST)
  220.             CALL ZPTINT(SYMBOL(5,I),1,IODLST)
  221.             CALL PUTCH(44,IODLST)
  222.             CALL ZPTINT(MOD(SYMBOL(6,I),1000),
  223.      +                  1,IODLST)
  224.             CALL PUTCH(44,IODLST)
  225.             CALL ZPTINT(SYMBOL(7,I),1,IODLST)
  226.             CALL PUTCH(44,IODLST)
  227.             CALL ZPTINT(SYMBOL(6,I)/1000,1,
  228.      +                  IODLST)
  229.             CALL PUTCH(10,IODLST)
  230.             I=I+1
  231.             IF (SYMBOL(1,I).EQ.1 .AND. I.LE.NSYMS)
  232.      +          GOTO 200
  233.         END IF
  234.         IF (SYMBOL(1,I).EQ.2 .AND. I.LE.NSYMS) THEN
  235.             CALL ZMESS('        Common blocks:',IODLST)
  236.  300        CALL ZOBLNK(12,IODLST)
  237.             CALL WRNAME(I)
  238.             CALL ZCHOUT(', First definition node: ',IODLST)
  239.             CALL ZPTINT(SYMBOL(4,I),1,IODLST)
  240.             CALL PUTCH(10,IODLST)
  241.             I=I+1
  242.             IF (SYMBOL(1,I).EQ.2 .AND. I.LE.NSYMS)
  243.      +          GOTO 300
  244.         END IF
  245.         IF (SYMBOL(1,I).EQ.3 .AND. I.LE.NSYMS) THEN
  246.             CALL ZMESS('        Names (Usage Unknown):',IODLST)
  247.  400        CALL ZOBLNK(12,IODLST)
  248.             CALL WRNAME(I)
  249.             CALL PUTCH(10,IODLST)
  250.             CALL WRBITS(I)
  251.             I=I+1
  252.             IF (SYMBOL(1,I).EQ.3 .AND. I.LE.NSYMS)
  253.      +          GOTO 400
  254.         END IF
  255. C SYMBOL(symbol_type,I) must = S_PU ... skip it
  256.         I=I+1
  257.         IF (SYMBOL(1,I).EQ.5 .AND. I.LE.NSYMS) THEN
  258.             CALL ZMESS('        Variables:',IODLST)
  259.  500        CALL ZOBLNK(12,IODLST)
  260.             CALL WRNAME(I)
  261.             IF (SYMBOL(7,I).NE.0) THEN
  262.                 CALL ZCHOUT('Array declarator node: ',IODLST)
  263.                 CALL ZPTINT(SYMBOL(7,I),1,IODLST)
  264.             END IF
  265.             CALL PUTCH(10,IODLST)
  266.             CALL WRBITS(I)
  267.             I=I+1
  268.             IF (SYMBOL(1,I).EQ.5 .AND. I.LE.NSYMS)
  269.      +          GOTO 500
  270.         END IF
  271.         IF (SYMBOL(1,I).EQ.6 .AND. I.LE.NSYMS) THEN
  272.             CALL ZMESS('        Parameters:',IODLST)
  273.  600        CALL ZOBLNK(12,IODLST)
  274.             CALL WRNAME(I)
  275.             CALL ZCHOUT(', Definition node ',IODLST)
  276.             CALL ZPTINT(SYMBOL(7,I),1,IODLST)
  277.             CALL PUTCH(10,IODLST)
  278.             CALL WRBITS(I)
  279.             I=I+1
  280.             IF (SYMBOL(1,I).EQ.6 .AND. I.LE.NSYMS)
  281.      +          GOTO 600
  282.         END IF
  283.         IF (SYMBOL(1,I).EQ.7 .AND. I.LE.NSYMS) THEN
  284.             CALL ZMESS('        Procedures:',IODLST)
  285.  700        CALL ZOBLNK(12,IODLST)
  286.             CALL WRNAME(I)
  287.             CALL PUTCH(10,IODLST)
  288.             CALL WRBITS(I)
  289.             I=I+1
  290.             IF (SYMBOL(1,I).EQ.7 .AND. I.LE.NSYMS)
  291.      +          GOTO 700
  292.         END IF
  293.         IF (SYMBOL(1,I).EQ.8 .AND. I.LE.NSYMS) THEN
  294.             CALL ZMESS('        Statement Functions:',IODLST)
  295.  800        CALL ZOBLNK(12,IODLST)
  296.             CALL WRNAME(I)
  297.             CALL ZCHOUT(', Definition node ',IODLST)
  298.             CALL ZPTINT(SYMBOL(7,I),1,IODLST)
  299.             CALL PUTCH(10,IODLST)
  300.             CALL WRBITS(I)
  301.             I=I+1
  302.             IF (SYMBOL(2,I).EQ.8 .AND. I.LE.NSYMS) GOTO 800
  303.         END IF
  304.         IF (SYMBOL(1,I).EQ.9 .AND. I.LE.NSYMS) THEN
  305.             CALL ZMESS('        Entry Points:',IODLST)
  306.  900        CALL ZOBLNK(12,IODLST)
  307.             CALL WRNAME(I)
  308.             CALL PUTCH(10,IODLST)
  309.             CALL WRBITS(I)
  310.             I=I+1
  311.             IF (SYMBOL(2,I).EQ.9 .AND. I.LE.NSYMS)
  312.      +          GOTO 900
  313.         END IF
  314.  
  315.         END
  316. C ----------------------------------------------------------------------
  317. C
  318. C       W R N A M E   -   Write symbol name and data type if any
  319. C
  320.  
  321.         SUBROUTINE WRNAME(N)
  322.         INTEGER N
  323.  
  324.         COMMON/VSIO/IODSYM,IODLST
  325.         INTEGER IODSYM,IODLST
  326.  
  327.         COMMON/VSSYMI/SYMIDX,NSYMS
  328.         INTEGER SYMIDX(1000),NSYMS
  329.  
  330.         COMMON/VSSYMD/SYMBOL
  331.         INTEGER SYMBOL(8,1000)
  332.  
  333.         CHARACTER*17 TYPTXT(-3:15)
  334.  
  335.         SAVE TYPTXT
  336.  
  337.         INTEGER TEXT(134)
  338.  
  339.         EXTERNAL ZYGTST,PUTLIN,ZCHOUT,PUTCH,ZPTINT
  340.  
  341.         DATA TYPTXT/
  342.      +'Main Program.    ',
  343.      +'BLOCK DATA.      ',
  344.      +'SUBROUTINE.      ',
  345.      +'Unknown.         ',
  346.      +'INTEGER.         ',
  347.      +'REAL.            ',
  348.      +'LOGICAL.         ',
  349.      +'COMPLEX.         ',
  350.      +'DOUBLE PRECISION.',
  351.      +'CHARACTER.       ',
  352.      +'DOUBLE COMPLEX.  ',
  353.      +'Generic.         ',
  354.      +'Hollerith.       ',
  355.      +'Label.           ',
  356.      +'Substring spec.  ',
  357.      +'LOGICAL*1.       ',
  358.      +'LOGICAL*2.       ',
  359.      +'INTEGER*2.       ',
  360.      +'REAL*16.         '/
  361.  
  362.         CALL ZYGTST(SYMBOL(2,N),TEXT)
  363.         CALL PUTLIN(TEXT,IODLST)
  364.         IF (SYMBOL(1,N).EQ.2 .OR.
  365.      +      SYMBOL(1,N).EQ.1) RETURN
  366.         CALL PUTCH(32,IODLST)
  367.         CALL ZCHOUT(TYPTXT(SYMBOL(4,N)),IODLST)
  368.         IF (SYMBOL(5,N).NE.0) THEN
  369.             CALL PUTCH(42,IODLST)
  370.             IF (SYMBOL(5,N).GT.0) THEN
  371.                 CALL ZPTINT(SYMBOL(5,N),1,IODLST)
  372.             ELSE
  373.                 CALL ZCHOUT('(Node ',IODLST)
  374.                 CALL ZPTINT(-SYMBOL(5,N),1,IODLST)
  375.                 CALL PUTCH(41,IODLST)
  376.             END IF
  377.         END IF
  378.         CALL PUTCH(32,IODLST)
  379.  
  380.         END
  381. C ----------------------------------------------------------------------
  382. C
  383. C       W R B I T S   -   Write meaning of attribute bits
  384. C
  385.  
  386.         SUBROUTINE WRBITS(N)
  387.         INTEGER N
  388.  
  389.         INTEGER NBITS
  390.         PARAMETER (NBITS=22)
  391.  
  392.         COMMON/VSIO/IODSYM,IODLST
  393.         INTEGER IODSYM,IODLST
  394.  
  395.         COMMON/VSSYMD/SYMBOL
  396.         INTEGER SYMBOL(8,1000)
  397.  
  398.         INTEGER BITS,I
  399.         CHARACTER*50 BITTXT(NBITS)
  400.  
  401.         SAVE BITTXT,/VSIO/,/VSSYMD/
  402.  
  403.         INTEGER ZIAND
  404.         EXTERNAL ZMESS,ZIAND
  405.  
  406.         DATA (BITTXT(I),I=1,19)/
  407.      +'                Declared EXTERNAL.                ',
  408.      +'                Declared INTRINSIC.               ',
  409.      +'                Formal parameter.                 ',
  410.      +'                Explicitly typed.                 ',
  411.      +'                In ASSIGN statement.              ',
  412.      +'                Assigned to on lhs of "=".        ',
  413.      +'                In READ input list.               ',
  414.      +'                In DATA statement.                ',
  415.      +'                Statement function formal param.  ',
  416.      +'                In EQUIVALENCE statement.         ',
  417.      +'                In COMMON block.                  ',
  418.      +'                Used as an actual argument.       ',
  419.      +'                Standard intrinsic function.      ',
  420.      +'                Called as a function.             ',
  421.      +'                In an expression.                 ',
  422.      +'                Called as a subroutine.           ',
  423.      +'                Used as a DO-loop index.          ',
  424.      +'                Actual argument to external.      ',
  425.      +'                Parameter value known.            '/
  426.         DATA (BITTXT(I),I=20,NBITS)/
  427.      +'                Equivalenced into a common block. ',
  428.      +'                *** unassigned flag bit ***.      ',
  429.      +'                In INCLUDE file.                  '/
  430.  
  431.         BITS=SYMBOL(6,N)
  432.  
  433.         DO 100 I=1,NBITS
  434.             IF (ZIAND(BITS,1).NE.0) CALL ZMESS(BITTXT(I),IODLST)
  435.             BITS=BITS/2
  436.  100    CONTINUE
  437.  
  438.         END
  439.